Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/mdi/ttedit/toolbar.bas

BASIC Source File | 1994-11-28 | 15KB | 442 lines

Option Explicit

Dim ButtonCount As Integer
Dim StatusText As String   ' The statusbar caption

Dim Parents() As Form  ' the parent form of each button
Dim Menus() As Menu  'array of menus each button is linked to

Const BUTTONS_DOWN = 100
Const BUTTONS_DISABLED = 200
Global Const RIGHT_JUSTIFY_BUTTONS = -2
Global Const SPACE_BETWEEN_BUTTONS = -1

' Flags for monitoring ToolTips
Dim TT_Control As Control
Dim TT_CurrentWindow  As Integer
Dim TT_StartTime As Long
Dim TT_Visible As Integer
Dim TT_Point As PointAPI
Dim TT_LastDisplayed As Long

Function BaseButton (Index As Integer) As Integer
     BaseButton = Index
     If Index >= BUTTONS_DISABLED Then
    BaseButton = Index - BUTTONS_DISABLED
     ElseIf Index >= BUTTONS_DOWN Then
    BaseButton = Index - BUTTONS_DOWN
     End If
End Function

'
' This loop generates the Disabled and Down images ready for use.
'
Sub Create_OtherButtons (ButtonParent As Form, PicBox As PictureBox, BC As Integer, Start As Integer, Finish As Integer)
   ButtonCount = BC
   ReDim Preserve Parents(ButtonCount)
   ReDim Preserve Menus(ButtonCount)
   Dim X As Integer
   For X = Start To Finish
       PicBox.Picture = ButtonParent.ToolButton(X).Picture
       PushDown PicBox
       Load ButtonParent.ToolButton(BUTTONS_DOWN + X)
       ButtonParent.ToolButton(BUTTONS_DOWN + X).Left = ButtonParent.ToolButton(X).Left
       ButtonParent.ToolButton(BUTTONS_DOWN + X).Top = ButtonParent.ToolButton(X).Top
       ButtonParent.ToolButton(BUTTONS_DOWN + X).Tag = ButtonParent.ToolButton(X).Tag
       ButtonParent.ToolButton(BUTTONS_DOWN + X).Picture = PicBox.Image
       PicBox.Picture = ButtonParent.ToolButton(X).Picture
       PicBox.Cls
       DisableButton PicBox
       Load ButtonParent.ToolButton(BUTTONS_DISABLED + X)
       ButtonParent.ToolButton(BUTTONS_DISABLED + X).Left = ButtonParent.ToolButton(X).Left
       ButtonParent.ToolButton(BUTTONS_DISABLED + X).Top = ButtonParent.ToolButton(X).Top
       ButtonParent.ToolButton(BUTTONS_DISABLED + X).Tag = ButtonParent.ToolButton(X).Tag
       ButtonParent.ToolButton(BUTTONS_DISABLED + X).Picture = PicBox.Image
       Set Parents(X) = ButtonParent
   Next
End Sub

'
' This actually creates the Disabled image from the Up image.
' We need a picture box for this to work
'
Private Sub DisableButton (Button As PictureBox)

 Dim SX1 As Integer
 Dim SX2 As Integer
 Dim SY1 As Integer
 Dim SY2 As Integer
 Dim DX As Integer
 Dim DY As Integer
 Dim R As Integer
 Dim LR As Long
 Dim rgbFace As Long
 Dim rgbShadow As Long
 Dim rgbHilight As Long
 Dim rgbFrame As Long
 Dim Dest_hDC As Integer
 Dim hdcMono As Integer
 Dim hbmMono As Integer
 Dim hbmTemp As Integer
 Dim hbmDefault  As Integer
 Dim hdcTemp As Integer
 Dim hbr As Integer
 Dim hbrOld As Integer


  SX1 = 1
  SY1 = 1
  SX2 = Button.ScaleWidth - 3
  SY2 = Button.ScaleHeight - 3
  DX = 1
  DY = 1

  Dest_hDC = Button.hDC
  rgbFace = GetSysColor(COLOR_BTNFACE)
  rgbShadow = GetSysColor(COLOR_BTNSHADOW)
  rgbHilight = GetSysColor(COLOR_BTNHIGHLIGHT)
  rgbFrame = GetSysColor(COLOR_WINDOWFRAME)
  hdcTemp = CreateCompatibleDC(Dest_hDC)
  hbmTemp = CreateCompatibleBitmap(Dest_hDC, SX2 - SX1 + 1, SY2 - SY1 + 1)

  hdcMono = CreateCompatibleDC(Dest_hDC)
  hbmMono = CreateBitmap(SX2 - SX1 + 1, SY2 - SY1 + 1, 1, 1, ByVal 0&)
  R = SelectObject(hdcMono, hbmMono)
  R = SelectObject(hdcTemp, hbmTemp)

  R = BitBlt(hdcTemp, DX, DY, SX2 - SX1 + 1, SY2 - SY1 + 1, Dest_hDC, SX1, SY1, SRCCOPY)

  R = PatBlt(hdcMono, DX, DY, SX2 - SX1 + 1, SY2 - SY1 + 1, WHITENESS)
  LR = SetBkColor(hdcTemp, rgbFace)     ' // 1's in mono -> 1
  R = BitBlt(hdcMono, DX, DY, SX2 - SX1 + 1, SY2 - SY1 + 1, hdcTemp, SX1, SY1, SRCCOPY)
  LR = SetBkColor(hdcTemp, rgbHilight)  ' // 1's in mono -> 1
  R = BitBlt(hdcMono, DX, DY, SX2 - SX1 + 1, SY2 - SY1 + 1, hdcTemp, SX1, SY1, SRCPAINT)
  LR = SetTextColor(Dest_hDC, &H0)  '      // 0's in mono -> 0 (for ROP)
  LR = SetBkColor(Dest_hDC, &HFFFFFF) ' // 1's in mono -> 1

  hbr = CreateSolidBrush(rgbHilight)
  hbrOld = SelectObject(Dest_hDC, hbr)
  R = BitBlt(Dest_hDC, DX + 1, DY + 1, SX2 - SX1 + 1, SY2 - SY1 + 1, hdcMono, SX1, SY1, &HB8074A)

  R = SelectObject(Dest_hDC, hbrOld)
  R = DeleteObject(hbr)
  '     // Gray out picture
  hbr = CreateSolidBrush(rgbShadow)
  hbrOld = SelectObject(Dest_hDC, hbr)
'       // Draw the shadow color where we have 0's in the mask.

  R = BitBlt(Dest_hDC, DX, DY, SX2 - SX1 + 1, SY2 - SY1 + 1, hdcMono, SX1, SY1, &HB8074A)
  R = SelectObject(Dest_hDC, hbrOld)
  R = DeleteObject(hbr)

  R = DeleteDC(hdcMono)
  R = DeleteDC(hdcTemp)
  R = DeleteObject(hbmMono)
  R = DeleteObject(hbmTemp)

  Button.Refresh
End Sub

Private Sub DisplayHelp (Help$)
    If Len(Help$) Then   ' Double check help$
    ' Make sure help form is invisible:
     frmToolTip.Hide

     ' Change caption of label:
     frmToolTip.Label1.Caption = Help$

     ' Offset the form from the cursor
     frmToolTip.Top = (TT_Point.Y + TT_Control.Height + 10) * Screen.TwipsPerPixelY
     frmToolTip.Left = TT_Point.X * Screen.TwipsPerPixelX

     frmToolTip.Width = (frmToolTip.Label1.Width + 6) * Screen.TwipsPerPixelX
     frmToolTip.Height = (frmToolTip.Label1.Height + 2) * Screen.TwipsPerPixelY

     If Screen.Width < frmToolTip.Width + frmToolTip.Left Then frmToolTip.Left = Screen.Width - 1.1 * frmToolTip.Width

     ' Make sure form is on top:
     frmToolTip.ZOrder

     ' Show form without the focus:
     If ShowWindow(frmToolTip.hWnd, SW_SHOWNOACTIVATE) Then
     End If
     TT_Visible = True
      Else
     ' Hide the form:
     frmToolTip.Hide
     TT_Visible = False
      End If
End Sub

Private Sub EnableButton (Button As PictureBox)
    Button.Cls
    Button.Refresh
    Button.Enabled = True
End Sub

Function GetButtonState (Index As Integer)
   GetButtonState = Menus(Index).Checked
End Function

'
' This calculates the number we need to use in the Sendmessage to
' Click the linked menu
'
Function GetMenuIndex (mnu As Menu) As Integer
   Dim X As Integer, Index  As Integer
   Dim F As Form
   Set F = mnu.Parent
   For X = 0 To F.Controls.Count - 1
     If TypeOf F.Controls(X) Is Menu Then Exit For
   Next
   Do While Not F.Controls(X + Index) Is mnu
      Index = Index + 1
   Loop
   GetMenuIndex = Index + 1
End Function

Function GetMenuTag (Index As Integer) As String
    If Not Menus(Index) Is Nothing Then GetMenuTag = Menus(Index).Tag
End Function

Sub LinkMenu (ButtonID As Integer, mnu As Menu)
   Set Menus(ButtonID) = mnu
End Sub

Sub PositionButtons (Positions() As Integer, ToolBar As Control)
   ' We need to position the buttons because the position of buttons cannot be
   ' guaranteed when run on machines with Large screen fonts if designed in small fonts mode.
   Dim X As Integer
   Dim Direction As Integer
   Dim Next_Left As Integer
   Dim LastToolButton
   For X = 0 To UBound(Positions)
     Select Case Positions(X)
       Case RIGHT_JUSTIFY_BUTTONS
    Direction = RIGHT_JUSTIFY_BUTTONS
    Next_Left = ToolBar.ScaleWidth - ToolBar.Parent.ToolButton(LastToolButton).Width
       Case SPACE_BETWEEN_BUTTONS
    If Direction <> RIGHT_JUSTIFY_BUTTONS Then
       Next_Left = Next_Left + ToolBar.Parent.ToolButton(0).Width / 3
    Else
       Next_Left = Next_Left - ToolBar.Parent.ToolButton(0).Width / 3
    End If
       Case Else
    LastToolButton = Positions(X)
    ToolBar.Parent.ToolButton(Positions(X)).Left = Next_Left
    ToolBar.Parent.ToolButton(Positions(X) + BUTTONS_DOWN).Left = Next_Left
    ToolBar.Parent.ToolButton(Positions(X) + BUTTONS_DISABLED).Left = Next_Left
    If Direction <> RIGHT_JUSTIFY_BUTTONS Then
       Next_Left = Next_Left + ToolBar.Parent.ToolButton(Positions(X)).Width
    Else
       Next_Left = Next_Left - ToolBar.Parent.ToolButton(Positions(X)).Width
    End If
     End Select
   Next
End Sub

Private Sub PushDown (PicBox As PictureBox)
     Dim X As Integer
     Dim mWidth As Integer
     Dim mHeight As Integer
     PicBox.Cls
     mHeight = PicBox.ScaleHeight
     mWidth = PicBox.ScaleWidth

     ' The next 3 lines change the look of the button when pressed down
     ' Change the FillColor property of PicBox to see the effects
'     PicBox.FillColor = &HC0&     ' Red Pictures
     PicBox.FillColor = &H404040  ' Grey pictures
     PicBox.DrawMode = 15
     PicBox.Line (0, 0)-(PicBox.ScaleWidth - 2, PicBox.ScaleHeight - 2), , B

     ' Copy the image 2 pixels down and 2 pixels right
     X = BitBlt(PicBox.hDC, 3, 3, mWidth - 4, mHeight - 4, PicBox.hDC, 2, 2, SRCCOPY)

     PicBox.DrawMode = 13
     PicBox.Line (2, 2)-(mWidth - 2, 2), RGB(192, 192, 192)
     PicBox.Line (2, 3)-(2, mHeight - 2), RGB(192, 192, 192)
     PicBox.Line (1, 1)-(1, mHeight - 2), &H808080
     PicBox.Line (1, 1)-(mWidth - 2, 1), &H808080
     PicBox.Line (2, mHeight - 2)-(mWidth - 2, mHeight - 2), RGB(192, 192, 192)
     PicBox.Line (mWidth - 2, 2)-(mWidth - 2, mHeight - 1), RGB(192, 192, 192)
     PicBox.Refresh
End Sub

Sub SetStatusText (Message As String)
   StatusText = Message
End Sub

Private Sub ShowButtonDisabled (Index As Integer)
    Dim F As Form
    Set F = Parents(Index)
    F.ToolButton(Index).Visible = False
    F.ToolButton(BUTTONS_DOWN + Index).Visible = False
    F.ToolButton(BUTTONS_DISABLED + Index).Visible = Menus(Index).Visible
End Sub

Private Sub ShowButtonDown (Index As Integer)
  Dim F As Form
  Set F = Parents(Index)
  F.ToolButton(Index).Visible = False
  F.ToolButton(BUTTONS_DOWN + Index).Visible = Menus(Index).Visible
  F.ToolButton(BUTTONS_DISABLED + Index).Visible = False
  Do While GetKeyState(MK_LBUTTON) < 0
     DoEvents
  Loop
End Sub

Private Sub ShowButtonUp (Index As Integer)
  Dim F As Form
  Set F = Parents(Index)
  F.ToolButton(Index).Visible = Menus(Index).Visible
  F.ToolButton(BUTTONS_DOWN + Index).Visible = False
  F.ToolButton(BUTTONS_DISABLED + Index).Visible = False
End Sub

Sub SynchButtons ()
  Dim X As Integer
  Dim mnu As Menu
  For X = 0 To ButtonCount
   If Not Menus(X) Is Nothing Then
     Set mnu = Menus(X)
     If mnu.Enabled Then
       If mnu.Checked Then
      Call ShowButtonDown(X)
       Else
      Call ShowButtonUp(X)
       End If
     Else
    ShowButtonDisabled (X)
     End If
    End If
  Next
End Sub

Sub ToolButtonClick (Index As Integer)
    Dim C As Control, F   As Form
    Dim X As Integer
    Dim retval As Long
    On Local Error Resume Next
    If Not Menus(Index) Is Nothing Then
      Set F = Menus(Index).Parent
      retval = SendMessage(F.hWnd, WM_COMMAND, GetMenuIndex(Menus(Index)), ByVal 0&)
    End If
End Sub

Sub ToolButtonMouseDown (Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Index = BaseButton(Index)
    If Button = MK_LBUTTON And Menus(Index).Enabled Then ShowButtonDown Index
End Sub

Sub ToolButtonMouseUp (Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
   Dim F As Form
   Dim ButtonClicked As Integer
   Index = BaseButton(Index)
   If Button = MK_LBUTTON Then
     If Menus(Index).Enabled And Menus(Index).Visible Then Call ShowButtonUp(Index)
     Set F = Parents(Index)
     ButtonClicked = True
     If X / Screen.TwipsPerPixelX < 0 Then ButtonClicked = False
     If Y / Screen.TwipsPerPixelY < 0 Then ButtonClicked = False
     If X / Screen.TwipsPerPixelX > F.ToolButton(Index).Width Then ButtonClicked = False
     If Y / Screen.TwipsPerPixelY > F.ToolButton(Index).Height Then ButtonClicked = False
     If ButtonClicked Then ToolButtonClick (Index)
   End If
End Sub

Sub ToolHelp (C As Control, X As Single, Y As Single)
    Dim PT As PointAPI
    If C Is TT_Control And TT_Visible Then Exit Sub
    Call GetCursorPos(PT)
    TT_CurrentWindow = WindowfromPoint(PT.Y, PT.X)
    TT_StartTime = GetTickCount()
    Set TT_Control = C
    TT_Point.X = PT.X - X / Screen.TwipsPerPixelX
    TT_Point.Y = PT.Y - Y / Screen.TwipsPerPixelY
    If TT_Visible Then Call DisplayHelp(CStr(C.Tag))
End Sub

Sub TT_Test ()
   Dim PT As PointAPI
   Dim NOT_OK As Integer
   If TT_Visible Then TT_LastDisplayed = GetTickCount()
   If TT_StartTime > 0 Then
     Call GetCursorPos(PT)
     If WindowfromPoint(PT.Y, PT.X) = TT_CurrentWindow Then
    If TT_Visible Then
      If CStr(TT_Control.Tag) <> frmToolTip.Label1 Then
         DisplayHelp (CStr(TT_Control.Tag))
         Exit Sub
      End If
      If PT.X < TT_Point.X Then NOT_OK = True
      If PT.Y < TT_Point.Y Then NOT_OK = True
      If PT.X > TT_Point.X + TT_Control.Width Then NOT_OK = True
      If PT.Y > TT_Point.Y + TT_Control.Height Then NOT_OK = True
      If NOT_OK Then
         If TT_Visible Then Call DisplayHelp("")
         TT_CurrentWindow = -1
         Exit Sub
      End If
    End If
    If (GetTickCount() - TT_StartTime > 600 Or GetTickCount() - TT_LastDisplayed < 300) And TT_Visible = False Then
       Call DisplayHelp(CStr(TT_Control.Tag))
    End If
     Else
    If TT_Visible Then Call DisplayHelp("")
    TT_CurrentWindow = -1
     End If
   End If
End Sub

Sub UpdateStatusBar (StatusBar As Control)
    Dim SB_Parent As Form
    Dim PT As PointAPI
    Static CurrentStatusText As String
    Static CurrentExtraCaptionText As String
    Dim F As Form
    Dim wPoint As PointAPI
    Dim Temp$
    Dim Window As Integer
    Dim Row As Long, Col As Long
    Dim C As Control

    Set SB_Parent = StatusBar.Parent
    Temp$ = SB_Parent.lblDateTime
    If IsDate(Temp$) Then
       If Minute(TimeValue(Temp$)) <> Minute(Now) Then SB_Parent.lblDateTime = Format(Now, "Medium Date") & " " & Format(Now, "hh:mm")
    Else
       SB_Parent.lblDateTime = Format(Now, "Medium Date") & " " & Format(Now, "hh:mm")
    End If
    Temp$ = ""
    If GetKeyState(KEY_NUMLOCK) = 1 Then Temp$ = "NUM"
    If SB_Parent.lblNumLock <> Temp$ Then SB_Parent.lblNumLock = Temp$
    Temp$ = ""
    If GetKeyState(KEY_CAPITAL) = 1 Then Temp$ = "CAPS"
    If SB_Parent.lblCapslock <> Temp$ Then SB_Parent.lblCapslock = Temp$
    GetCursorPos PT
    If WindowfromPoint(PT.Y, PT.X) = GetTopWindow(MDI.hWnd) Then StatusText = "For Help, press F1"
    If StatusText <> CurrentStatusText Then
       CurrentStatusText = StatusText
       SB_Parent.lblStatusText = "  " & StatusText
    End If
    Temp$ = ""
    Set F = MDI.ActiveForm
    If Not F Is Nothing Then
      Set C = F.ActiveControl
      If Not C Is Nothing Then
    If TypeOf C Is TextBox Then
       Row = SendMessage(C.hWnd, EM_LINEFROMCHAR, -1, ByVal 0&)
       Col = SendMessage(C.hWnd, EM_LINEINDEX, -1, ByVal 0&)
       Col = C.SelStart - Col
       Temp$ = "Line " & Row + 1 & " : Col " & Col + 1
    End If
      End If
    End If
    If Temp$ <> CurrentExtraCaptionText Then
       CurrentExtraCaptionText = Temp$
       SB_Parent.lblExtraCaption = Temp$
    End If
End Sub